PC Plus SuperCD (UK) 1994 June

home *** CD-ROM | disk | FTP | other *** search

/ PC Plus SuperCD (UK) 1994 June / PC Plus Super CD coverdisc Issue 93 June 1994.iso / suprdisk / button / frmbutto.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-04-12 | 49.2 KB | 1,302 lines

VERSION 2.00 Begin Form frmButton BackColor = &H00C0C0C0& Caption = "Buttons" ClientHeight = 6630 ClientLeft = 675 ClientTop = 1035 ClientWidth = 9480 ClipControls = 0 'False FontTransparent = 0 'False Height = 7320 Icon = FRMBUTTO.FRX:0000 Left = 615 LinkTopic = "Form1" ScaleHeight = 442 ScaleMode = 3 'Pixel ScaleWidth = 632 Top = 405 Width = 9600 Begin PictureBox picMaster AutoRedraw = -1 'True AutoSize = -1 'True Height = 13980 Left = 4350 Picture = FRMBUTTO.FRX:0302 ScaleHeight = 930 ScaleMode = 3 'Pixel ScaleWidth = 58 TabIndex = 11 Top = 945 Visible = 0 'False Width = 900 End Begin Frame Frame1 BackColor = &H00C0C0C0& ClipControls = 0 'False ForeColor = &H00C0C0C0& Height = 2895 Left = 7500 TabIndex = 15 Top = 2205 Visible = 0 'False Width = 1290 Begin CommandButton cmdFonts Cancel = -1 'True Caption = "&Fonts" Height = 420 Left = 150 TabIndex = 10 Top = 1215 Width = 990 End Begin TextBox tbxPrint Height = 645 Left = 150 MultiLine = -1 'True TabIndex = 8 Top = 360 Width = 990 End Begin CommandButton cmdCancel Caption = "Cancel" Height = 420 Left = 150 TabIndex = 17 Top = 1800 Width = 990 End Begin CommandButton cmdOK Caption = "OK" Height = 420 Left = 150 TabIndex = 16 Top = 2340 Width = 990 End End Begin PictureBox picTools Align = 1 'Align Top BackColor = &H00C0C0C0& ClipControls = 0 'False Height = 915 Left = 0 ScaleHeight = 59 ScaleMode = 3 'Pixel ScaleWidth = 630 TabIndex = 9 Top = 0 Width = 9480 Begin Label lblToolType Alignment = 2 'Center BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "Pen" Height = 240 Left = 7650 TabIndex = 13 Top = 90 Width = 1590 End Begin Label lblCol BackColor = &H00000000& BorderStyle = 1 'Fixed Single Height = 330 Left = 7500 TabIndex = 12 Top = 45 Width = 1890 End End Begin PictureBox picButton AutoRedraw = -1 'True BackColor = &H00FFFFFF& BorderStyle = 0 'None ClipControls = 0 'False ForeColor = &H00FFFFFF& Height = 510 Index = 2 Left = 1725 ScaleHeight = 34 ScaleMode = 3 'Pixel ScaleWidth = 41 TabIndex = 4 Top = 5850 Visible = 0 'False Width = 615 End Begin PictureBox picButton AutoRedraw = -1 'True BackColor = &H00FFFFFF& BorderStyle = 0 'None ClipControls = 0 'False FillColor = &H00808080& ForeColor = &H00808080& Height = 510 Index = 1 Left = 900 ScaleHeight = 34 ScaleMode = 3 'Pixel ScaleWidth = 41 TabIndex = 3 Top = 5850 Visible = 0 'False Width = 615 End Begin PictureBox picButton AutoRedraw = -1 'True BackColor = &H00FFFFFF& BorderStyle = 0 'None ClipControls = 0 'False ForeColor = &H00000000& Height = 510 Index = 0 Left = 150 ScaleHeight = 34 ScaleMode = 3 'Pixel ScaleWidth = 41 TabIndex = 2 Top = 5850 Visible = 0 'False Width = 615 End Begin PictureBox picDraw BackColor = &H00FFFFFF& BorderStyle = 0 'None Height = 2445 Left = 0 ScaleHeight = 163 ScaleMode = 3 'Pixel ScaleWidth = 176 TabIndex = 0 Top = 945 Visible = 0 'False Width = 2640 End Begin Label lblPrint BackStyle = 0 'Transparent Height = 645 Left = 5775 TabIndex = 14 Top = 3375 Visible = 0 'False Width = 1140 End Begin Label lblButton BackStyle = 0 'Transparent Caption = "Off (Use 'Update' to view)" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 2 Left = 1725 TabIndex = 7 Top = 5535 Visible = 0 'False Width = 2415 End Begin Label lblButton BackStyle = 0 'Transparent Caption = "Down" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 1 Left = 825 TabIndex = 6 Top = 5535 Visible = 0 'False Width = 540 End Begin Label lblButton BackStyle = 0 'Transparent Caption = "Up" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 195 Index = 0 Left = 150 TabIndex = 5 Top = 5535 Visible = 0 'False Width = 315 End Begin Label lblTest BackStyle = 0 'Transparent Caption = "Test" Height = 195 Left = 8025 TabIndex = 1 Top = 1035 Visible = 0 'False Width = 840 End Begin Image imgTest Height = 555 Left = 8025 Top = 1350 Width = 615 End Begin Menu mnuInvisible Caption = "Invisible" Visible = 0 'False Begin Menu mnuMessage Caption = "Message" End End Begin Menu mnuOptions Caption = "&Options" Begin Menu mnuToolBar Caption = "&Toolbar" Checked = -1 'True End Begin Menu mnuExit Caption = "E&xit" End End Begin Menu mnuButton Caption = "&Buttons" Begin Menu mnuButtons Caption = "New &Size Button" Index = 24 Shortcut = {F2} End Begin Menu mnuButtons Caption = "Next &Button" Index = 25 Shortcut = {F3} End Begin Menu mnuButtons Caption = "&UpDate the Disabled Button" Index = 26 End Begin Menu mnuButtons Caption = "&Save to Bitmap or Disk" Index = 27 Shortcut = {F4} End Begin Menu mnuButtons Caption = "&Clear Current Button" Index = 28 End Begin Menu mnuButtons Caption = "&Load a Master Bitmap" Index = 29 End Begin Menu mnuButtons Caption = "&View or Edit the Master Bitmap" Index = 30 End Begin Menu mnuButtons Caption = "&Add Text to the current button" Index = 31 End End Begin Menu mnuTools Caption = "&Tools" Begin Menu mnuToolArray Caption = "Fill" Index = 16 Shortcut = {F5} End Begin Menu mnuToolArray Caption = "Pen" Index = 17 Shortcut = {F6} End Begin Menu mnuToolArray Caption = "Line" Index = 18 Shortcut = {F7} End Begin Menu mnuToolArray Caption = "Box" Index = 19 Shortcut = {F8} End Begin Menu mnuToolArray Caption = "Filled Box" Index = 20 Shortcut = {F9} End Begin Menu mnuToolArray Caption = "Circle" Index = 21 End Begin Menu mnuToolArray Caption = "Filled Circle" Index = 22 Shortcut = {F11} End End Begin Menu mnuHelp Caption = "&Help" End Option Explicit Option Compare Text 'Gets the nearest solid color (QBColor) Declare Function GetNearestColor Lib "gdi" (ByVal hDC%, ByVal Col As Long) As Long 'Used to paint the picture Declare Sub FloodFill Lib "Gdi" (ByVal hDC%, ByVal X%, ByVal Y%, ByVal crColor As Long) Declare Sub ExtFloodFill Lib "Gdi" (ByVal hDC%, ByVal X%, ByVal Y%, ByVal crColor As Long, ByVal wFillType%) Const FLOODFILLSURFACE = 1 Dim MouseDown As Integer Dim BlockAcross As Integer Dim BlockDown As Integer Dim DrawPicHeight As Integer Dim DrawPicWidth As Integer Dim Drawing As Integer Dim LineX As Integer Dim LineY As Integer Dim XPos As Integer Dim YPos As Integer Dim pMouseDown As Integer Dim XDiff As Integer Dim YDiff As Integer Dim NoEntry As Integer Dim Printing As Integer Dim ToolType As Integer Dim Painting As Integer Dim Loading As Integer Dim CurrentColor As Long Dim ButtonData() As bType Sub Change_Position () Dim n As Integer 'Resize the various elements and move them into position picDraw.Move 0, picTools.Height, DrawPicWidth, DrawPicHeight picDraw.Visible = True For n = 0 To 2 B(n).Width = BitMap.ButtonWidth B(n).Height = BitMap.ButtonHeight lblButton(n).Move n * (BitMap.ButtonWidth + 4) + 3, picDraw.Top + picDraw.Height + 3 B(n).Move n * (BitMap.ButtonWidth + 4) + 3, lblButton(n).Top + lblButton(n).Height + 3 B(n).Visible = True Next n lblTest.Move picDraw.Width + 4, picTools.Height imgTest.Move picDraw.Width + 4, lblTest.Top + lblTest.Height End Sub Sub Change_ToolBar () If picTools.Height > HEIGHT_OF_BUTTONS + 2 Then 'Show only color buttons picTools.Height = HEIGHT_OF_BUTTONS + 2 Else picTools.Height = (HEIGHT_OF_BUTTONS + 2) * 2 'Show all buttons End If mnuToolBar.Checked = Not mnuToolBar.Checked End Sub ' This function calls the Main Save routine # ' It is invoked by the following events # ' 1. A new button is being loaded and the current button has not been saved # ' 2. A new size button is being loaded and the current button or the master # ' bitmap has not been saved # ' 3. If the Save button has been clicked or Save has been selected from the menu. # ' 4. On exit if a button or bitmap has not been saved # '======================================================================================== Function Check_For_Changes (WhichSave As Integer) As Integer If Not Loading Then frmMainSave.Tag = WhichSave frmMainSave.Show 1 Check_For_Changes = frmMainSave.Tag End If End Function ' This routine clears the drawing area without selecting a new button# ' and without saving any changes # '======================================================================= Sub Clear_Button () B(0).Cls If Editing Then BitMap.Position = frmBitMap!picBitMap.ScaleHeight Editing = False End If Draw_Button_Borders BitBlt B(1).hDC, 4, 4, B(1).ScaleWidth - 7, B(1).ScaleHeight - 7, B(0).hDC, 4, 4, SRCCOPY Re_Paint_Picture ButtonChanged = False End Sub ' If routines are selected from the menu bar they # ' are still called by simulating clicking the buttons # ' this insures that any 'sticky' buttons are released # ' or stuck down where appropriate # '======================================================== Sub Click_Button (ButNum As Integer) Tool_MouseDown ButNum Tool_MouseUp ButNum End Sub ' This is the cancel button in the Add Text frame (frame1) Sub cmdCancel_Click () Printing = False Frame1.Visible = False lblPrint.Visible = False HelpItem = 0 End Sub Sub cmdFonts_Click () 'Show the Fonts window Get_Fonts tbxPrint.SetFocus End Sub ' See mnuText_Click for explanation of the 'Add Text' routine # ' This routine copies the area of the form covered by the test button including # ' any text in the label lblPrint and 'AND's it to the 'Up' button # ' As it is an AND operation not all colors will work. So you will have to experiment # '======================================================================================== Sub cmdOK_Click () BitBlt B(0).hDC, 0, 0, B(0).ScaleWidth, B(0).ScaleHeight, frmButton.hDC, imgTest.Left, imgTest.Top, SRCAND lblPrint.Visible = False ButtonChanged = True UpDated = False Frame1.Visible = False Printing = False B(0).Refresh Re_Paint_Picture HelpItem = 0 End Sub ' This draws the borders of the up, down & disabled buttons ' '============================================================== Sub Draw_Button_Borders () Dim n As Integer For n = 0 To 2 B(n).Cls Draw_Button_Edges n Next n 'Up Button Raised_Button B(0) 'Down Button B(1).Line (1, 1)-(BitMap.ButtonWidth - 1, 1), &H808080 'QBColor(8) B(1).Line (1, 2)-(BitMap.ButtonWidth - 1, 2), &H808080 'QBColor(8) B(1).Line (1, 1)-(1, BitMap.ButtonHeight - 1), &H808080 'QBColor(8) B(1).Line (2, 1)-(2, BitMap.ButtonHeight - 1), &H808080 'QBColor(8) 'Off Button Raised_Button B(2) End Sub ' This draws the edges of the up, down & disabled buttons ' '============================================================ Sub Draw_Button_Edges (Num As Integer) B(Num).Line (1, 0)-(BitMap.ButtonWidth - 1, 0), 0 B(Num).Line (1, BitMap.ButtonHeight - 1)-(BitMap.ButtonWidth - 1, BitMap.ButtonHeight - 1), 0 B(Num).Line (0, 1)-(0, BitMap.ButtonHeight - 1), 0 B(Num).Line (BitMap.ButtonWidth - 1, 1)-(BitMap.ButtonWidth - 1, BitMap.ButtonHeight - 1), 0 B(Num).PSet (0, 0), &HFFFFFF B(Num).PSet (0, BitMap.ButtonHeight - 1), &HFFFFFF B(Num).PSet (BitMap.ButtonWidth - 1, 0), &HFFFFFF B(Num).PSet (BitMap.ButtonWidth - 1, BitMap.ButtonHeight - 1), &HFFFFFF End Sub Sub Draw_Grid () Dim n As Integer For n = 24 To DrawPicWidth - 24 Step 8 picDraw.Line (n, 24)-(n, DrawPicHeight - 24), &H808080 'QBColor(8) Next n For n = 24 To DrawPicHeight - 24 Step 8 picDraw.Line (24, n)-(DrawPicWidth - 24, n), &H808080 'QBColor(8) Next n End Sub ' PEN TOOL # ' This is the only routine that draws onto the drawing area. # ' As it draws the corresponding points are plotted onto the # ' Up & Down buttons. # ' All the other tools draw onto the Up button and the Up button # ' is copied to the down button and stretched onto the drawing area # '======================================================================== Sub Draw_Point () Dim n As Integer If NoEntry Then Exit Sub ' Don't re-enter this routine while in DoEvents *** NoEntry = True Do While MouseDown If Inside_Array(BlockAcross, BlockDown) Then If GetNearestColor(B(0).hDC, B(0).Point(BlockAcross, BlockDown)) <> CurrentColor Then If Not ButtonChanged Then ButtonChanged = True picDraw.Line (BlockAcross * 8 + 1, BlockDown * 8 + 1)-(BlockAcross * 8 + 7, BlockDown * 8 + 7), CurrentColor, BF For n = 0 To 1 B(n).PSet (BlockAcross + n, BlockDown + n), CurrentColor Next n End If End If DoEvents '*** Check if the button has been released Loop NoEntry = False UpDated = False imgTest = B(0).Image End Sub ' BOX, BOXFILL, CIRCLE, CIRCLEFILL and LINE Tools # ' The first 'SELECT CASE' ensures that the outline # ' of the shape you are drawing remains static if # ' you move the cursor outside the drawing area. # ' All the tools in this routine draw to the Up button # ' which is copied to the other buttons by Re_Paint_Picture # '============================================================= Sub Draw_Tool () Dim SaveX As Integer Dim SaveY As Integer Dim CentreX As Single Dim CentreY As Single Dim Aspect As Single Dim Radius As Single If NoEntry Then Exit Sub NoEntry = True picDraw.FillStyle = 1 picDraw.DrawMode = 10 picDraw.DrawWidth = 4 Do While MouseDown Select Case BlockAcross Case Is < Box.rLeft SaveX = (Box.rLeft * 8) + 4 Case Box.rLeft To Box.rRight SaveX = (BlockAcross * 8) + 4 Case Else SaveX = (Box.rRight * 8) + 4 End Select Select Case BlockDown Case Is < Box.rTop SaveY = (Box.rTop * 8) + 4 Case Box.rTop To Box.rBottom SaveY = (BlockDown * 8) + 4 Case Else SaveY = (Box.rBottom * 8) + 4 End Select Select Case ToolType Case T_LINE picDraw.Line (LineX, LineY)-(SaveX, SaveY) picDraw.Line (LineX, LineY)-(SaveX, SaveY) Case Else 'T_BOX, T_BOX_FILL, T_CIRCLE, T_CIRCLEFILL picDraw.Line (LineX, LineY)-(SaveX, SaveY), , B picDraw.Line (LineX, LineY)-(SaveX, SaveY), , B End Select DoEvents 'Check if the button has been released Loop NoEntry = False On Error Resume Next picDraw.DrawMode = 13 picDraw.DrawWidth = 1 Select Case ToolType Case T_LINE B(0).Line ((LineX - 4) \ 8, (LineY - 4) \ 8)-(SaveX \ 8, SaveY \ 8), CurrentColor B(0).PSet (SaveX \ 8, SaveY \ 8), CurrentColor Case T_BOX B(0).Line ((LineX - 4) \ 8, (LineY - 4) \ 8)-(SaveX \ 8, SaveY \ 8), CurrentColor, B Case T_BOXFILL B(0).FillStyle = 0 B(0).FillColor = CurrentColor B(0).Line ((LineX - 4) \ 8, (LineY - 4) \ 8)-(SaveX \ 8, SaveY \ 8), CurrentColor, B Case T_CIRCLEFILL, T_CIRCLE If ToolType = T_CIRCLEFILL Then B(0).FillStyle = 0 B(0).FillColor = CurrentColor End If If LineX > SaveX Then Swap LineX, SaveX 'assign the lowest values to LineX & LineY If LineY > SaveY Then Swap LineY, SaveY 'this makes it easier to do the calculations CentreX = LineX + (SaveX - LineX) \ 2 CentreY = LineY + (SaveY - LineY) \ 2 Radius = CentreX - LineX Aspect = CentreY - LineY Select Case Radius Case Is >= Aspect B(0).Circle (CentreX \ 8, CentreY \ 8), Radius \ 8, CurrentColor, , , (Aspect \ 8) / (Radius \ 8) Case Else B(0).Circle (CentreX \ 8, CentreY \ 8), Aspect \ 8, CurrentColor, , , (Aspect \ 8) / (Radius \ 8) End Select Case Else Rem End Select Re_Paint_Picture ButtonChanged = True B(0).FillStyle = 1 End Sub ' The Up button is painted then copied to the other buttons by Re_Paint_Picture Sub Flood () B(0).FillStyle = 0 B(0).FillColor = CurrentColor 'ExtFloodFill doesn't seem to work in 16 color, 800 X 600 video mode 'In this programme when AutoRedraw is true. 'So turn it off B(0).AutoRedraw = False ExtFloodFill B(0).hDC, BlockAcross, BlockDown, B(0).Point(BlockAcross, BlockDown), FLOODFILLSURFACE 'Turn it back on B(0).AutoRedraw = True 'Then copy the picture into the Device Context BitBlt B(0).hDC, 0, 0, BitMap.ButtonWidth, BitMap.ButtonHeight, frmButton.hDC, B(0).Left, B(0).Top, SRCCOPY ButtonChanged = True UpDated = False 'The disabled button has changed Raised_Button B(0) 'The paint is allowed to leak onto the Draw_Button_Edges 0 'borders of the button, so redraw them Re_Paint_Picture B(0).FillStyle = 1 End Sub Sub Form_Activate () HelpItem = 0 End Sub Sub Form_KeyDown (KeyCode As Integer, Shift As Integer) Dim SaveCode As Integer SaveCode = 0 If Not Shift Then Select Case KeyCode Case &H70 Cheap_Help Format$(HelpItem) Case &H79 'You can't assign F10 as a shortcut key 'in MENU DESIGN window so it's handled in code Click_Button BUTTON_CIRCLE Case Else SaveCode = KeyCode End Select KeyCode = SaveCode End If End Sub Sub Form_Load () Dim n As Integer On Error GoTo EndErr If GetSystemMetrics(SM_MOUSEPRESENT) = False Then MsgBox "This programme requires a mouse", 16, "No Mouse Detected" End End If ChDir app.Path Position_Form frmButton 'Global routine to centre forms on the screen For n = 0 To 2 picButton(n).BackColor = QBColor(7) Set B(n) = frmButton!picButton(n) 'Make picturebox variables this saves having to type in the full form and control every time Next n ToolBar_Ini keypreview = True windowstate = 2 CR = Chr$(13) & Chr$(10) 'Carriage return + line feed for Message Boxes picDraw.BackColor = QBColor(7) picDraw.Move 0, 0 Loading = True 'Flag to show that no buttons have been initialized yet frmButton.Show 'Remove these two lines to get rid of the annoying messages Cheap_Help "25" Cheap_Help Format$(HelpItem) Exit Sub EndErr: MsgBox Error$, 0, "Error No." & Str$(Err) 'Trap any unexpected errors End Resume End Sub Sub Form_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) HelpItem = 0 End Sub Sub Form_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) 'Switches from any tool to the pen if the right mouse button is pressed If Button And 2 Then Switch_To_Pen End Sub Sub Form_QueryUnload (CANCEL As Integer, UnloadMode As Integer) Dim z As Integer 'Check that nothing needs saving If ButtonChanged Then z = S_INDIVIDUAL_FILE Or S_TO_BITMAP_AND_FILE If BitMap.Changed Then z = z Or S_BITMAP If z > 0 Then CANCEL = (Check_For_Changes(z) = CANCEL_SAVE) 'Remove this line to get rid of the annoying message Cheap_Help "25" End Sub Sub Form_Unload (CANCEL As Integer) End End Sub ' The Toolbar doesn't exist as seperate buttons so calculate # ' which button has been clicked from the X & Y positions on # ' ToolBar picture. # '=============================================================== Function Get_ButNum (X As Integer, Y As Integer) As Integer Dim ButtonNum As Integer ButtonNum = X \ WIDTH_OF_BUTTONS 'The toolbar is in two rows 'So calculate the position along the bar If ButtonNum > TOTAL_BUTTONS \ 2 - 1 Then Get_ButNum = True Exit Function 'The cursor is beyond the last of the buttons End If If Y \ HEIGHT_OF_BUTTONS > 0 Then ButtonNum = 16 + ButtonNum 'If its the 2nd row, adjust the number Get_ButNum = ButtonNum End Function ' Used to write text on the Drawing area # '==========================================# 'THIS FUNCTION HAS BEEN DISABLED TO MAKE THE 'PROGRAMME COMPATABLE WITH VISUAL BASIC ver 2 Sub Get_Fonts () Cheap_Help "26" 'Fonts not available message Rem Remove the line above 'Cheap_Help "26", Rem add a common dialogue control to this form and Rem remove all the apostrophes from this point down Rem to enable this section if you have VB ver 3.0 'On Error GoTo DilErr 'CMDialog1.CancelError=true 'CMDialog1.FontName = lblPrint.FontName 'CMDialog1.FontSize = lblPrint.FontSize 'CMDialog1.FontBold = lblPrint.FontBold 'CMDialog1.FontItalic = lblPrint.FontItalic 'CMDialog1.FontUnderline = lblPrint.FontUnderline 'CMDialog1.FontStrikethru = lblPrint.FontStrikethru 'CMDialog1.Color = lblPrint.ForeColor ' ' 'CMDialog1.Flags = &H3& Or &H100& ' 'CMDialog1.Action = 4 'lblPrint.FontName = CMDialog1.FontName 'lblPrint.FontSize = CMDialog1.FontSize 'lblPrint.FontBold = CMDialog1.FontBold 'lblPrint.FontItalic = CMDialog1.FontItalic 'lblPrint.FontUnderline = CMDialog1.FontUnderline 'lblPrint.FontStrikethru = CMDialog1.FontStrikethru 'lblPrint.ForeColor = CMDialog1.Color ' 'Exit Sub 'DilErr: ' Exit Sub ' resume next End Sub ' Hide the 'Add Text frame if another button is clicked # '=========================================================== Sub Hide_Frame () If Frame1.Visible Then Frame1.Visible = False Printing = False End If End Sub Sub imgTest_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) 'Copy the 'Down' button onto the test button If Not Printing Then imgTest = B(1).Image HelpItem = 21 End Sub Sub imgTest_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) 'Copy the 'Up' button onto the test button If Not Printing Then imgTest = B(0).Image End Sub ' Start a new button Sub Initialize_Button () Drawing = True 'Disable the picDraw_Paint event Switch_To_Pen 'Start with the pen Click_Button BUTTON_BLACK 'and color black Draw_Button_Borders 'Draw the buttons and stretch the 'Up' button into the drawing area StretchBlt picDraw.hDC, 0, 0, picDraw.ScaleWidth, picDraw.ScaleHeight, B(0).hDC, 0, 0, B(0).ScaleWidth, B(0).ScaleHeight, SRCCOPY Draw_Grid 'Draw the grid on the drawing area imgTest = B(0).Image 'Reset the test button Drawing = False ButtonChanged = False If Editing Then BitMap.Position = frmBitMap!picBitMap.ScaleHeight Editing = False End If screen.MousePointer = 0 End Sub ' This is the label used to Add Text to the button ' See mnuText for an explanation Sub lblPrint_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) pMouseDown = True XPos = X YPos = Y End Sub Sub lblPrint_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single) 'Move the label If pMouseDown Then XDiff = X - XPos YDiff = Y - YPos lblPrint.Left = lblPrint.Left + ((XDiff) \ screen.TwipsPerPixelX) lblPrint.Top = lblPrint.Top + ((YDiff) \ screen.TwipsPerPixelY) End If End Sub Sub lblPrint_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) pMouseDown = False End Sub Sub lblToolType_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) mnuMessage.Caption = "Current selected tool && color" PopupMenu mnuInvisible, 2, lblToolType.Left, lblToolType.Top + 25 End Sub ' Loads a multi-button bitmap for editing Sub Load_BitMap () Dim z As Integer Dim n As Integer Dim FileName As String On Error GoTo LoadErr 'Check if the current button or master bitmap needs saving If ButtonChanged Then z = S_INDIVIDUAL_FILE Or S_TO_BITMAP_AND_FILE If BitMap.Changed Then z = z Or S_BITMAP If z > 0 Then n = Check_For_Changes(z) If n = CANCEL_SAVE Then Exit Sub 'Get the data file for the bitmap Do Directory.Show 1 FileName = Directory!text1 If FileName = "" Then Exit Sub If InStr(FileName, "_B.DAT") = 0 Then MsgBox "That is not a bitmap created by this programme" & CR & "The filename should end with _B.BMP", 48 Loop Until FileName = "" Or InStr(FileName, "_B.DAT") > 0 If Len(FileName) > 0 Then CurrentDirectory = Directory!Dir1.Path 'Save the working directory Unload Directory If Load_BitMap_Info(FileName) Then Exit Sub 'Read the data file and check if the bitmap exists 'Re-Size the buttons to fit the bitmap Resize_Box If Loading Then Show_Controls Loading = False End If 'Let the picture fit the bitmap frmBitMap!picBitMap.AutoSize = True frmBitMap!picBitMap.Picture = LoadPicture(FileName) frmBitMap!picBitMap.AutoSize = False BitMapLoaded = True Exit Sub LoadErr: MsgBox Error$ Exit Sub Resume Next End Sub ' This function reads the data file created when the master bitmap was saved # ' and checks that the BMP file exists # '================================================================================ Function Load_BitMap_Info (FileName As String) As Integer Dim handle As Integer Dim BitMapFile As String Dim Msg As String Dim SaveBitMap As BMP On Error GoTo GetErr SaveBitMap = BitMap 'Save the previous button information in case anything goes wrong BitMapFile = FileName 'The filename ends in _B.DAT. We need to check that ******_B.BMP exists 'So copy FileName into BitMapFile 'then :- ' Alter BitMapFile to a BMP file BitMapFile = Left$(BitMapFile, InStr(BitMapFile, "_B.DAT") - 1) & "_B.BMP" If FileLen(BitMapFile) < Len(BitMap) Then Error 32700 'FileLen will force an error if the file doesn't exist 'If the file is too short then generate an error handle = FreeFile Open FileName For Random As #handle Len = Len(BitMap) 'Open the ******_B.DAT data file Get #handle, , BitMap Close #handle If BitMap.ID <> BUTTON_ID Then Error 32700 'If the first 2 bytes don't equal the 'button ID then this file wasn't created by this programme 'So force an error FileName = BitMapFile 'Change the FileName to the BMP file GetOut: Exit Function GetErr: Msg = "Unable to load a file, (See above). " Select Case Err Case 53 'Data file or BMP file not found Msg = Msg & UCase$(Error$) & CR & CR & "The DATA file and the BMP file must be in the same " & CR & "directory" Case 32700 'User defined error Msg = Msg & "Wrong format" & CR & CR & "That is not a valid BUTTONS data file" Case Else Msg = Msg & Error$ End Select MsgBox Msg, 48, BitMapFile Load_BitMap_Info = True 'Indicates to the calling procedure that there was an error BitMap = SaveBitMap Resume GetOut End Function Sub Load_Individual () Cheap_Help "27" End Sub Sub mnuButtons_Click (Index As Integer) Select Case Index Case BUTTON_RESIZE New_Size_Button Case BUTTON_NEXT Next_Button Case BUTTON_UPDATE To BUTTON_PRINT Click_Button Index Case Else Rem End Select End Sub Sub mnuExit_Click () Unload frmButton End Sub Sub mnuHelp_Click () Cheap_Help Format$(HelpItem) End Sub Sub mnuToolArray_Click (Index As Integer) Click_Button Index End Sub ' The toolbar can be reduced to show only the color buttons Sub mnuToolBar_Click () Change_ToolBar Change_Position End Sub Sub New_Size_Button () Dim z As Integer Dim n As Integer Hide_Frame 'Hide the Add Text frame if it is visible 'Check for changes and exit if Cancel is selected If ButtonChanged Then z = S_INDIVIDUAL_FILE Or S_TO_BITMAP_AND_FILE If BitMap.Changed Then z = z Or S_BITMAP If z > 0 Then n = Check_For_Changes(z) If n = CANCEL_SAVE Then Exit Sub 'Get the dimensions of the new button frmNew.Show 1 If Len(frmNew.Tag) > 0 Then BitMap.Buttons = 0 'It's a new button so we don't need the master bitmap Unload frmBitMap BitMapLoaded = False Resize_Box If Loading Then 'Make the various elements visible if this is the first Show_Controls 'button after the programme has loaded Loading = False End If End If End Sub Sub Next_Button () Dim z As Integer Dim n As Integer 'If it is the first button since loading then ask for the size If Loading Then Click_Button BUTTON_RESIZE Exit Sub End If Hide_Frame 'Hide the 'Add Text' controls 'Save Changes If ButtonChanged Then z = S_INDIVIDUAL_FILE Or S_TO_BITMAP If z > 0 Then n = Check_For_Changes(z) If n = CANCEL_SAVE Then Exit Sub Initialize_Button End Sub ' Draws the buttons onto the ToolBar using BitBlt API ' The picture holding the tools is 32 buttons deep and ' 2 buttons wide (Up and Down buttons) ' So button #1 is the first row in the picture, button 2 is ' the second and so on. ' The Up button is at position 0 across and the Down ' button is at position 0 +1 + the width of the buttons '======================================================= Sub Paint_Button (ToolNo As Integer, ButtonState As Integer) Dim ButtonAcross As Integer Dim ButtonDown As Integer Dim PicLeft As Integer If ToolNo <= 15 Then ButtonAcross = ToolNo ButtonDown = 0 Else ButtonAcross = ToolNo - 16 ButtonDown = 1 End If ButtonAcross = WIDTH_OF_BUTTONS * ButtonAcross ButtonDown = HEIGHT_OF_BUTTONS * ButtonDown If Not ButtonState Then PicLeft = 0 Else PicLeft = WIDTH_OF_BUTTONS + 1 End If BitBlt picTools.hDC, ButtonAcross, ButtonDown, WIDTH_OF_BUTTONS, HEIGHT_OF_BUTTONS, picMaster.hDC, PicLeft, HEIGHT_OF_BUTTONS * ToolNo, SRCCOPY End Sub Sub picButton_MouseDown (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If Button And 2 Then HelpItem = Index + 17 End If End Sub Sub picDraw_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim n As Integer Dim SaveColor As Long MouseDown = True 'If the right button is pressed and the tool isn't Pen then change to the pen If (Button And 2) Then HelpItem = 20 If ToolType <> T_PEN Then Switch_To_Pen Exit Sub End If End If 'Exit if centre button is pressed If Button And 4 Then Exit Sub BlockAcross = X \ 8 BlockDown = Y \ 8 Select Case ToolType Case T_PEN SaveColor = CurrentColor If Button And 2 Then 'The right button is the button background color (light grey) CurrentColor = &HC0C0C0 'QBColor(7) End If Draw_Point CurrentColor = SaveColor Case T_LINE, T_BOX, T_BOXFILL, T_CIRCLE, T_CIRCLEFILL If Inside_Array(BlockAcross, BlockDown) Then 'Check it's inside the drawing area LineX = BlockAcross * 8 + 4 LineY = BlockDown * 8 + 4 Draw_Tool End If Case T_FILL Flood Case Else Rem End Select End Sub Sub picDraw_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single) If Button Then 'Curs.Across = X 'Curs.Down = Y BlockAcross = X \ 8 BlockDown = Y \ 8 End If End Sub Sub picDraw_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) MouseDown = False End Sub Sub picDraw_Paint () Dim X As Integer Dim Y As Integer If Drawing Or Loading Or Printing Then Exit Sub Re_Paint_Picture End Sub Sub picMaster_Click () 'This is the bitmap that holds all the toolbar buttons End Sub ' This is the picture at the top of the form that holds the toolbar Sub picTools_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim TN As Integer MouseDown = True If Button And 1 Then TN = Get_ButNum(CInt(X), CInt(Y)) If TN > -1 Then Tool_MouseDown TN ElseIf Button And 2 Then Show_Function X, Y HelpItem = X \ WIDTH_OF_BUTTONS + 1 If HelpItem > 16 Then HelpItem = 22 End If End Sub Sub picTools_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim TN As Integer MouseDown = False If Button And 1 Then TN = Get_ButNum(CInt(X), CInt(Y)) If TN > -1 Then Tool_MouseUp TN End If End Sub Sub picTools_Paint () Show_ToolBar End Sub ' This draws the highlight and shadow around the edge of the buttons Sub Raised_Button (pic As PictureBox) pic.Line (1, 1)-(BitMap.ButtonWidth - 2, 1), &HFFFFFF 'QBColor(15) pic.Line (2, 2)-(BitMap.ButtonWidth - 3, 2), &HFFFFFF pic.Line (1, 1)-(1, BitMap.ButtonHeight - 2), &HFFFFFF pic.Line (2, 2)-(2, BitMap.ButtonHeight - 3), &HFFFFFF pic.Line (BitMap.ButtonWidth - 2, 1)-(BitMap.ButtonWidth - 2, BitMap.ButtonHeight - 1), &H808080 'QBColor(8) pic.Line (BitMap.ButtonWidth - 3, 2)-(BitMap.ButtonWidth - 3, BitMap.ButtonHeight - 1), &H808080 'QBColor(8) pic.Line (1, BitMap.ButtonHeight - 2)-(BitMap.ButtonWidth - 1, BitMap.ButtonHeight - 2), &H808080'QBColor(8) pic.Line (2, BitMap.ButtonHeight - 3)-(BitMap.ButtonWidth - 1, BitMap.ButtonHeight - 3), &H808080'QBColor(8) End Sub ' Most of the Tools operate directly onto the 'Up' button # ' This is then StretchBlt'ed onto the drawing area and # ' BitBlt'ed onto the other buttons # ' To save writing tons of code to calculate the appearance# ' of the disabled button, it is only calculated when the # ' button is saved or if the Update button is pressed. # Sub Re_Paint_Picture () StretchBlt picDraw.hDC, 0, 0, picDraw.ScaleWidth, picDraw.ScaleHeight, B(0).hDC, 0, 0, B(0).ScaleWidth, B(0).ScaleHeight, SRCCOPY 'The grid is destroyed by StretchBlt so re-draw it Draw_Grid 'Copy the drawing area of the 'Up' button to the 'Down' button offset by 1 pixel across and 1 pixel down BitBlt B(1).hDC, 4, 4, BitMap.ButtonWidth - 6, BitMap.ButtonHeight - 6, B(0).hDC, 3, 3, SRCCOPY B(1).Refresh 'Copy the 'Up' Button to the test button imgTest = B(0).Image UpDated = False End Sub ' Draws a new size box Sub Resize_Box () Drawing = True UpDated = True screen.MousePointer = 11 'The Drawing area is 8 times the size of the buttons DrawPicWidth = BitMap.ButtonWidth * 8 DrawPicHeight = BitMap.ButtonHeight * 8 'Set the limits of the drawing area (We don't want to draw on the button borders) 'This routine fills the user defined data Box, with the 4 corners of the drawing area 'It's the same as:- ' Box.rLeft=3 ' Box.rTop=3 ' Box.rRight=BitMap.ButtonWidth - 4 ' Box.rBottom=BitMap.ButtonHeight - 4 SetRect Box, 3, 3, BitMap.ButtonWidth - 4, BitMap.ButtonHeight - 4 Change_Position Initialize_Button End Sub ' When the programme first loads, all the labels are invisible ' When the first button has been drawn we need to make them visible Sub Show_Controls () Dim n As Integer If lblTest.Visible Then Exit Sub lblTest.Visible = True For n = 0 To 2 lblButton(n).Visible = True B(n).Visible = True Next n End Sub Sub Show_Frame () If Loading Then MsgBox "No button to operate on" Exit Sub End If HelpItem = 16 'Show the frame that holds the controls for 'Add Text' Printing = True lblPrint.Move imgTest.Left + 3, imgTest.Top + 3, imgTest.Width - 4, imgTest.Height - 4 Frame1.Move picDraw.Width + 1, imgTest.Top + imgTest.Height + 5 lblPrint.Visible = True Frame1.Visible = True tbxPrint = "" tbxPrint.SetFocus End Sub ' If the right mouse button is held down over one of the toolbar # ' buttons, a brief description of the buttons function is shown # ' on a pop up menu # '=================================================================== Sub Show_Function (X, Y) Dim Msg As String Dim Num As Integer Num = Get_ButNum(CInt(X), CInt(Y)) Select Case Num Case 0 To 15: Msg = "Colour = QBColor (" & Format$(Num) & ")" Case BUTTON_FILL To BUTTON_CIRCLEFILL: Msg = mnuToolArray(Num).Caption Case BUTTON_RESIZE To BUTTON_PRINT: Msg = mnuButtons(Num).Caption Case Else: Msg = "BUTTONS. CopyRight G.Fairchild 1994" End Select mnuMessage.Caption = Msg PopupMenu mnuInvisible, 2, X, Y + 20 End Sub ' Draws the complete toolbar by calling Paint_Button ' 32 times, to draw the 32 buttons Sub Show_ToolBar () Dim n As Integer If Painting Then Exit Sub Painting = True For n = 0 To TOTAL_BUTTONS - 1 Paint_Button n, ButtonData(n).Down Next n Painting = False End Sub ' Swaps the values of two variables so that the first one is the smallest Sub Swap (Big As Integer, Small As Integer) Dim SaveVar As Integer SaveVar = Big Big = Small Small = SaveVar End Sub ' Each time a new button is loaded the Pen is selected Sub Switch_To_Pen () If ToolType <> T_PEN Then Click_Button BUTTON_PEN End If End Sub Sub tbxPrint_Change () lblPrint = tbxPrint End Sub ' Called when the mouse is released over a toolbar button ' or the button is clicked in code Sub Tool_Click (ToolNum As Integer) Dim z As Integer 'Use the normal cursor unless the Fill Tool is selected If picDraw.MousePointer <> 0 And Not ButtonData(BUTTON_FILL).Down Then picDraw.MousePointer = 0 ElseIf ToolNum = BUTTON_FILL Then picDraw.MousePointer = 10 End If Select Case ToolNum Case 0 To 15 CurrentColor = QBColor(ToolNum) lblCol.BackColor = CurrentColor 'lblCol is the label in the toolbar that shows the current color Case BUTTON_FILL To BUTTON_CIRCLEFILL If InStr(mnuToolArray(ToolNum).Caption, Chr$(9)) Then lblToolType = Left$(mnuToolArray(ToolNum).Caption, 6) Else lblToolType = mnuToolArray(ToolNum).Caption End If ToolType = ToolNum - 15 Case BUTTON_RESIZE New_Size_Button Case BUTTON_NEXT Next_Button Case BUTTON_UPDATE Update_Button Case BUTTON_SAVE z = Check_For_Changes(S_SHOW_ALL) If z <> CANCEL_SAVE Then Initialize_Button Case BUTTON_CLEAR Clear_Button Case BUTTON_LOAD frmLoad.Show 1 z = Val(frmLoad.Tag) Unload frmLoad Select Case z Case 1: Load_Individual Case 2: Load_BitMap Case Else: Rem End Select Case BUTTON_VIEW If BitMapLoaded Then frmBitMap.Show 1 Else MsgBox "There's nothing to view" End If Case BUTTON_PRINT Show_Frame Case Else Rem End Select End Sub ' Called by a Mouse_Down event in picTools Sub Tool_MouseDown (ToolNum As Integer) If ToolNum > TOTAL_BUTTONS - 1 Then Exit Sub 'It should be impossible to select a button > 31 'but just in case it happens - exit the sub 'Put the button down if it is not already stuck down If ButtonData(ToolNum).Down = False Then ButtonData(ToolNum).Down = True Paint_Button ToolNum, ButtonData(ToolNum).Down End If 'If it's a color button or a tool button, make it stick If ToolNum < 23 Then ButtonData(ToolNum).stuck = True End Sub ' Called by a Mouse_Up event in picTools (The Toolbar) Sub Tool_MouseUp (ToolNum As Integer) If ToolNum > TOTAL_BUTTONS - 1 Then Exit Sub 'Save the stuck buttons so that we can release them next time Static SaveColBut As Integer Static SaveToolBut As Integer Select Case ButtonData(ToolNum).Group Case NO_GROUP 'It's not a 'Sticky' button so release it ButtonData(ToolNum).Down = False Paint_Button ToolNum, ButtonData(ToolNum).Down Case COLOR_GROUP 'If it's not already stuck down then stick it & release the previous button If ToolNum <> SaveColBut Then ButtonData(SaveColBut).Down = False Paint_Button SaveColBut, ButtonData(SaveColBut).Down ButtonData(SaveColBut).stuck = False SaveColBut = ToolNum End If Case TOOL_GROUP 'If it's not already stuck down then stick it & release the previous button If ToolNum <> SaveToolBut And SaveToolBut <> 0 Then ButtonData(SaveToolBut).Down = False Paint_Button SaveToolBut, ButtonData(SaveToolBut).Down ButtonData(SaveToolBut).stuck = False SaveToolBut = ToolNum Else SaveToolBut = ToolNum End If Case Else: Rem End Select 'Invoke the routine associated with the button Tool_Click ToolNum End Sub ' Initialize the ButtonData and assign the group values Sub ToolBar_Ini () Dim n As Integer ReDim ButtonData(0 To TOTAL_BUTTONS - 1) For n = 0 To 15 ButtonData(n).Group = COLOR_GROUP Next n For n = 16 To 22 ButtonData(n).Group = TOOL_GROUP Next n 'Menu Design wont let you assign F10 to a menu item so do it in code mnuToolArray(BUTTON_CIRCLE).Caption = mnuToolArray(BUTTON_CIRCLE).Caption & Chr$(9) & "F10" End Sub